home *** CD-ROM | disk | FTP | other *** search
/ Just Call Me Internet / Just Call Me Internet.iso / prog / atari / m2 / cat3src / magic / i / magicsys.i < prev    next >
Encoding:
Modula Implementation  |  1997-10-26  |  10.5 KB  |  400 lines
  1. (*----------------------------------------------------------------------*
  2.  *                                                                      *
  3.  *         MAGIC   Modula's  All purpose  GEM  Interface  Cadre         *
  4.  *                 ÿ         ÿ            ÿ    ÿ          ÿ             *
  5.  *----------------------------------------------------------------------*
  6.  * Version 3.30  02.02.1992     (C)90/91/92 by Peter Hellinger Software *
  7.  *----------------------------------------------------------------------*
  8.  *            Dieses Modul ist urheberrechtlich geschtzt.              *
  9.  *                                                                      *
  10.  * Die Ver”ffentlichung des Quelltextes oder Teilen daraus in schrift-  *
  11.  * licher Form, insbesondere in Zeitschriften, sowie die Verbreitung    *
  12.  * ber Public-Domain-H„ndler bedarf der ausdrcklichen schriftlichen   *
  13.  * Genehmigung des Autors!                                              *
  14.  *                                                                      *
  15.  * Der Autor gibt hiermit die ausdrckliche Erlaubnis, das Modul jeder- *
  16.  * zeit auch im Quelltext weiterzugegeben, sofern dessen Text und ins-  *
  17.  * besondere dieser Urheberrechts-Vermerk nicht ver„ndert wird, und     *
  18.  * durch die Weitergabe kein finanzieller Nutzen entsteht. Der Autor    *
  19.  * beh„lt sich das Recht vor, diese Erlaubnis jederzeit u. ohne Angaben *
  20.  * von Grnden zu widerrufen.                                           *
  21.  *----------------------------------------------------------------------*)
  22.  
  23. IMPLEMENTATION MODULE MagicSys;
  24.  
  25. (*----------------------------------------------------------------------*
  26.  * MagicSys     Dieses Modul soll Inkompatibilit„ten zwischen den ein-  *
  27.  *              zelnen Compilern aufheben.                              *
  28.  *                                                                      *
  29.  *              WARNUNG:  Dieses Modul ist auf ABSOLUT UNTERSTER EBENE! *
  30.  *----------------------------------------------------------------------*
  31.  * Int. Vers | Datum    | Name | Žnderung                               *
  32.  *-----------+----------+------+----------------------------------------*
  33.  *  3.00     | 18.01.92 |  Hp  |                                        *
  34.  *-----------+----------+------+----------------------------------------*)
  35.  
  36.  
  37.  
  38. (* IMPLEMENTATION FšR  >>> Megamax-Modula-2 <<< *)
  39. (*                                              *)
  40. (*$R-   Range-Checks                            *)
  41. (*$S-   Stack-Check                             *)
  42. (*                                              *)
  43. (*----------------------------------------------*)
  44.  
  45.  
  46.  
  47.  
  48.  
  49.  
  50.  
  51.  
  52.  
  53. FROM SYSTEM IMPORT ADDRESS, BYTE, WORD;
  54.  
  55.  
  56.  
  57.  FROM SYSTEM IMPORT ASSEMBLER;
  58.  IMPORT PrgCtrl;
  59.  
  60.  
  61.  
  62.  
  63. TYPE    PtrPD =         POINTER TO PD;
  64.         PD =            RECORD
  65.                          pLowtpa:       ADDRESS;
  66.                          pHitpa:        ADDRESS;
  67.                          pTbase:        ADDRESS;
  68.                          pTlen:         lCARDINAL;
  69.                          pDbase:        ADDRESS;
  70.                          pDlen:         lCARDINAL;
  71.                          pBbase:        ADDRESS;
  72.                          pBlen:         lCARDINAL;
  73.                          pDta:          ADDRESS;
  74.                          pParent:       ADDRESS;
  75.                          res1:          ADDRESS;
  76.                          pEnv:          ADDRESS;
  77.                          devx:          ARRAY [0..5] OF Byte;
  78.                          res2:          Byte;
  79.                          defdrv:        Byte;
  80.                          pUndef:        ARRAY [0..17] OF lCARDINAL;
  81.                          pCmdlin:       ARRAY [0..126] OF CHAR;
  82.                         END;
  83.  
  84. TYPE    PtrSYSHDR =     POINTER TO SYSHDR;
  85.         SYSHDR =        RECORD
  86.                          osEntry:       sCARDINAL;
  87.                          osVersion:     sCARDINAL;
  88.                          osStart:       ADDRESS;
  89.                          osBase:        ADDRESS;
  90.                          osMembot:      ADDRESS;
  91.                          osShell:       ADDRESS;
  92.                          osMagic:       ADDRESS;
  93.                          osGendat:      lCARDINAL;
  94.                          osPalmode:     sCARDINAL;
  95.                          osGendatg:     sCARDINAL;
  96.                          osCountry:     lCARDINAL;
  97.                          root:          ADDRESS;
  98.                          kbshift:       ADDRESS;
  99.                          run:           ADDRESS;
  100.                         END;
  101.  
  102.  
  103. VAR cast2:     RECORD
  104.                  CASE : CARDINAL OF
  105.                   0:  hi:   LOC;
  106.                       lo:   LOC;|
  107.                   1:  int:  sINTEGER;|
  108.                   2:  card: sCARDINAL;|
  109.                   3:  set:  sBITSET;|
  110.                   4:  wrd:  sWORD;|
  111.                  END;
  112.                 END;
  113.  
  114. VAR cast4:     RECORD
  115.                  CASE : CARDINAL OF
  116.                   0:  b1:  LOC;
  117.                       b2:  LOC;
  118.                       b3:  LOC;
  119.                       b4:  LOC;|
  120.                   1:  int: lINTEGER;|
  121.                   2:  crd: lCARDINAL;|
  122.                   3:  set: lBITSET;|
  123.                   4:  wrd: lWORD;|
  124.                   5:  adr: ADDRESS;|
  125.                  END;
  126.                 END;
  127.  
  128. VAR base: PtrPD;
  129.     sys:  PtrSYSHDR;
  130.     acc:  BOOLEAN;
  131.  
  132.  
  133. PROCEDURE CastToChar (REF  value: ARRAY OF LOC): CHAR;
  134. BEGIN
  135.  
  136.   RETURN CHAR (value[HIGH (value)]);  
  137.  
  138.  
  139. END CastToChar;
  140.  
  141. PROCEDURE CastToByte (REF  value: ARRAY OF LOC): Byte;
  142. BEGIN
  143.  
  144.    RETURN BYTE (value[HIGH (value)]);  
  145.  
  146.  
  147. END CastToByte;
  148.  
  149. PROCEDURE CastToByteset (REF  value: ARRAY OF LOC): ByteSet;
  150. BEGIN
  151.  
  152.    RETURN ByteSet (value[HIGH (value)]);  
  153.  
  154.  
  155. END CastToByteset;
  156.  
  157. PROCEDURE CastToInt (REF  value: ARRAY OF LOC): sINTEGER;
  158. BEGIN
  159.  IF HIGH (value) = 0 THEN
  160.   cast2.int:= 0;  cast2.lo:= value[0];
  161.  ELSE
  162.   cast2.hi:= value[HIGH (value)-1];  cast2.lo:= value[HIGH (value)];
  163.  END;
  164.  RETURN cast2.int;
  165. END CastToInt;
  166.  
  167. PROCEDURE CastToCard (REF  value: ARRAY OF LOC): sCARDINAL;
  168. BEGIN
  169.  IF HIGH (value) = 0 THEN
  170.   cast2.card:= 0;  cast2.lo:= value[0];
  171.  ELSE
  172.   cast2.hi:= value[HIGH (value)-1];  cast2.lo:= value[HIGH (value)];
  173.  END;
  174.  RETURN cast2.card;
  175. END CastToCard;
  176.  
  177. PROCEDURE CastToBitset (REF  value: ARRAY OF LOC): sBITSET;
  178. BEGIN
  179.  IF HIGH (value) = 0 THEN
  180.   cast2.set:= {};
  181.   cast2.lo:= value[0];
  182.  ELSE
  183.   cast2.hi:= value[HIGH (value)-1];
  184.   cast2.lo:= value[HIGH (value)];
  185.  END;
  186.  RETURN cast2.set;
  187. END CastToBitset;
  188.  
  189. PROCEDURE CastToWord (REF  value: ARRAY OF LOC): sWORD;
  190. BEGIN
  191.  IF HIGH (value) = 0 THEN
  192.   cast2.int:= 0;
  193.   cast2.lo:= value[0];
  194.  ELSE
  195.   cast2.hi:= value[HIGH (value)-1];
  196.   cast2.lo:= value[HIGH (value)];
  197.  END;
  198.  RETURN cast2.wrd;
  199. END CastToWord;
  200.  
  201. PROCEDURE CastToLInt (REF  value: ARRAY OF LOC): lINTEGER;
  202. BEGIN
  203.  CASE HIGH (value) OF
  204.   0:    cast4.int:= 0H;
  205.         cast4.b4:= value[0];
  206.         |
  207.   1:    cast4.int:= 0H;
  208.         cast4.b3:= value[HIGH (value)-1];
  209.         cast4.b4:= value[HIGH (value)];
  210.         |
  211.   ELSE  cast4.b1:= value[HIGH (value)-3];
  212.         cast4.b2:= value[HIGH (value)-2];
  213.         cast4.b3:= value[HIGH (value)-1];
  214.         cast4.b4:= value[HIGH (value)];
  215.  END;
  216.  RETURN cast4.int;
  217. END CastToLInt;
  218.  
  219. PROCEDURE CastToLCard (REF  value: ARRAY OF LOC): lCARDINAL;
  220. BEGIN
  221.  CASE HIGH (value) OF
  222.   0:    cast4.crd:= 0H;
  223.         cast4.b4:= value[0];
  224.         |
  225.   1:    cast4.crd:= 0H;
  226.         cast4.b3:= value[HIGH (value)-1];
  227.         cast4.b4:= value[HIGH (value)];
  228.         |
  229.   ELSE  cast4.b1:= value[HIGH (value)-3];
  230.         cast4.b2:= value[HIGH (value)-2];
  231.         cast4.b3:= value[HIGH (value)-1];
  232.         cast4.b4:= value[HIGH (value)];
  233.  END;
  234.  RETURN cast4.crd;
  235. END CastToLCard;
  236.  
  237. PROCEDURE CastToLBitset (REF  value: ARRAY OF LOC): lBITSET;
  238. BEGIN
  239.  CASE HIGH (value) OF
  240.   0:    cast4.int:= 0H;
  241.         cast4.b4:= value[0];
  242.         |
  243.   1:    cast4.int:= 0H;
  244.         cast4.b3:= value[HIGH (value)-1];
  245.         cast4.b4:= value[HIGH (value)];
  246.         |
  247.   ELSE  cast4.b1:= value[HIGH (value)-3];
  248.         cast4.b2:= value[HIGH (value)-2];
  249.         cast4.b3:= value[HIGH (value)-1];
  250.         cast4.b4:= value[HIGH (value)];
  251.  END;
  252.  RETURN cast4.set;
  253. END CastToLBitset;
  254.  
  255. PROCEDURE CastToLWord (REF  value: ARRAY OF LOC): lWORD;
  256. BEGIN
  257.  CASE HIGH (value) OF
  258.   0:    cast4.crd:= 0;
  259.         cast4.b4:= value[0];
  260.         |
  261.   1:    cast4.crd:= 0;
  262.         cast4.b3:= value[HIGH (value)-1];
  263.         cast4.b4:= value[HIGH (value)];
  264.         |
  265.   ELSE  cast4.b1:= value[HIGH (value)-3];
  266.         cast4.b2:= value[HIGH (value)-2];
  267.         cast4.b3:= value[HIGH (value)-1];
  268.         cast4.b4:= value[HIGH (value)];
  269.  END;
  270.  RETURN cast4.wrd;
  271. END CastToLWord;
  272.  
  273. PROCEDURE CastToAddr (REF  value: ARRAY OF LOC): ADDRESS;
  274. BEGIN
  275.  CASE HIGH (value) OF
  276.   0:    cast4.crd:= 0H;
  277.         cast4.b4:= value[0];
  278.         |
  279.   1:    cast4.crd:= 0H;
  280.         cast4.b3:= value[HIGH (value)-1];
  281.         cast4.b4:= value[HIGH (value)];
  282.         |
  283.   ELSE  cast4.b1:= value[HIGH (value)-3];
  284.         cast4.b2:= value[HIGH (value)-2];
  285.         cast4.b3:= value[HIGH (value)-1];
  286.         cast4.b4:= value[HIGH (value)];
  287.  END;
  288.  RETURN cast4.adr;
  289. END CastToAddr;
  290.  
  291. PROCEDURE Basepage (): ADDRESS;
  292. BEGIN
  293.  RETURN base;
  294. END Basepage;
  295.  
  296. PROCEDURE Accessory (): BOOLEAN;
  297. BEGIN
  298.  RETURN acc;
  299. END Accessory;
  300.  
  301. PROCEDURE SysHeader (): ADDRESS;
  302. BEGIN
  303.  RETURN sys;
  304. END SysHeader;
  305.  
  306. PROCEDURE TosVersion (): sCARDINAL;
  307. BEGIN   
  308.  RETURN sys^.osVersion;
  309. END TosVersion;
  310.  
  311. PROCEDURE TosDate (): sCARDINAL;
  312. BEGIN
  313.  RETURN sys^.osGendatg;
  314. END TosDate;
  315.  
  316.  
  317.  
  318.  
  319. PROCEDURE Terminate (return: sINTEGER);
  320. BEGIN
  321.  
  322.  ASSEMBLER
  323.   MOVE.W  return(A6), -(SP)
  324.   MOVE.W  #76, -(SP)
  325.   TRAP    #1
  326.  END;
  327.  
  328.  
  329.  
  330.  
  331. END Terminate;
  332.  
  333. PROCEDURE CallGEM (function: sINTEGER; parablock: ADDRESS);
  334. BEGIN
  335.  
  336.  ASSEMBLER
  337.   MOVE.W  function(A6), D0
  338.   MOVE.L  parablock(A6), D1
  339.   TRAP    #2
  340.  END;
  341.  
  342.  
  343.  
  344.  
  345. END CallGEM;
  346.  
  347. PROCEDURE VqGdos (): LONGCARD;
  348. VAR x: LONGINT;
  349. BEGIN
  350.  
  351.  ASSEMBLER
  352.   MOVE.L  #-2, D0
  353.   TRAP    #2
  354.   MOVE.L  D0, x(A6)
  355.  END;
  356.  
  357.  
  358.  
  359.  
  360.  RETURN x;
  361. END VqGdos;
  362.  
  363.  VAR hdr[04F2H]: PtrSYSHDR; 
  364.  
  365.  
  366.  
  367. VAR a: ADDRESS;
  368.  
  369. PROCEDURE Super (VAR stack: ADDRESS);
  370. BEGIN
  371.  
  372.  a:= stack;
  373.  ASSEMBLER
  374.   MOVE.L  a, -(SP)
  375.   MOVE.W  #32, -(SP)
  376.   TRAP    #1
  377.   ADDQ.L  #6, SP
  378.   MOVE.L  D0, a
  379.  END;
  380.  stack:= a;
  381.  
  382.  
  383.  
  384.  
  385. END Super;
  386.  
  387. VAR y:   POINTER TO ADDRESS;
  388.     x:   ADDRESS;
  389.  
  390. BEGIN
  391.  
  392.  
  393.  
  394.  
  395.  PrgCtrl.GetBasePageAddr (base);
  396.  x:= Null;  Super (x);  sys:= hdr;  Super (x);
  397.  
  398.  acc:= (base # NIL) & (base^.pParent = Null);
  399. END MagicSys.
  400.